home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 03 - 1987 / 03.07 Jul 87 / forth source / Menu defs < prev   
Encoding:
Text File  |  1987-05-06  |  5.2 KB  |  259 lines  |  [TEXT/MACA]
  1. ( *** menu definition procedures. J.L. April 1987 *** )
  2.  
  3. ONLY FORTH ALSO ASSEMBLER ALSO MAC
  4.  
  5. HEX
  6. 4D444546 CONSTANT "mdef
  7. 0 CONSTANT mDrawMsg
  8. 1 CONSTANT mChooseMsg
  9. 2 CONSTANT mSizeMsg
  10. DECIMAL
  11.  
  12. CODE white
  13.     MOVE.L (A5),-(A6)
  14.     SUBQ.L #8,(A6)
  15.     RTS
  16. END-CODE MACH
  17.  
  18. CODE black
  19.     MOVE.L (A5),-(A6)
  20.     SUBI.L #16,(A6)
  21.     RTS
  22. END-CODE MACH
  23.  
  24. CODE gray
  25.     MOVE.L (A5),-(A6)
  26.     SUBI.L #24,(A6)
  27.     RTS
  28. END-CODE MACH
  29.  
  30. CODE ltgray
  31.     MOVE.L (A5),-(A6)
  32.     SUBI.L #32,(A6)
  33.     RTS
  34. END-CODE MACH
  35.  
  36. CODE dkgray
  37.     MOVE.L (A5),-(A6)
  38.     SUBI.L #40,(A6)
  39.     RTS
  40. END-CODE MACH
  41.  
  42. CODE w*
  43.     MOVE.L (A6)+,D1
  44.     MOVE.L (A6)+,D0
  45.     MULS.W D1,D0
  46.     MOVE.L D0,-(A6)
  47.     RTS
  48. END-CODE MACH
  49.  
  50. CODE w/
  51.     MOVE.L (A6)+,D1
  52.     MOVE.L (A6)+,D0
  53.     DIVS.W D1,D0
  54.     EXT.L  D0
  55.     MOVE.L D0,-(A6)
  56.     RTS
  57. END-CODE MACH
  58.     
  59. CODE w/mod
  60.     MOVE.L (A6)+,D1
  61.     MOVE.L (A6)+,D0
  62.     DIVS.W D1,D0
  63.     MOVE.L D0,D1
  64.     SWAP.W D1
  65.     EXT.L  D1
  66.     EXT.L  D0
  67.     MOVE.L D1,-(A6)
  68.     MOVE.L D0,-(A6)
  69.     RTS
  70. END-CODE MACH
  71.     
  72. ( *** menu record data structure *** )
  73.  0 CONSTANT menuID        ( integer )
  74.  2 CONSTANT menuWidth    ( integer )
  75.  4 CONSTANT menuHeight    ( integer )
  76.  6 CONSTANT menuProc    ( handle )
  77. 10 CONSTANT enableFlags ( longint )
  78. 14 CONSTANT menuData    ( Str255 and other data ) 
  79.     ( *** menu Data format *** )
  80.     ( counted string: menu title )
  81.     ( followed by 1 to 31 times: )
  82.     ( counted string: menu item  )
  83.     ( byte: item icon # )
  84.     ( byte: equivalent character )
  85.     ( byte: check mark character )
  86.     ( byte: text attributes )
  87.     ( .... )
  88.     ( end: zero byte. )
  89.  
  90. : list.menus 
  91.     32767 0 do 
  92.         i call getMhandle
  93.             ?dup IF ." Menu # " i . ." , handle " dup . cr 
  94.                     ." MenuData:" cr
  95.                     @ menuData + dup count type cr ( type menu title )
  96.                     dup c@ + 1+ ( start of first item string )
  97.                     BEGIN
  98.                     dup count dup
  99.                     WHILE type cr 
  100.                     dup c@ + 5 +
  101.                     REPEAT drop 
  102.             THEN
  103.         PAUSE loop
  104. ;
  105.  
  106. ( *** code moved to custom menu routine space starts here *** )
  107.  
  108. header start
  109.     JMP start  ( to be filled later )
  110. header temprect 8 allot
  111. header itemrect 8 allot
  112.  
  113. : * w* ;
  114. : / w/ ;
  115. : /mod w/mod ;
  116.  
  117. : mdef { message theMenu menuRect hitPt whichItem | 
  118.                 width height wd ht top left item# wi# -- }
  119.     theMenu @ dup menuwidth  + w@ -> width
  120.                         width 4 / -> wd 
  121.                   menuheight + w@ -> height  
  122.                        height 4 / -> ht
  123.     menuRect    w@ -> top
  124.     menuRect 2+ w@ -> left
  125.  
  126.     message CASE
  127.         mDrawMsg OF
  128.             height 0 DO
  129.                 4 0 DO 
  130.                 ['] temprect left i wd * + top j + over wd + over ht +
  131.                         call setrect   
  132.                 ['] tempRect 4 4 
  133.                     i CASE     0    OF white     ENDOF
  134.                             1    OF ltgray     ENDOF
  135.                             2     OF gray     ENDOF
  136.                             3    OF dkgray     ENDOF
  137.                          black 
  138.                       ENDCASE CALL FillRoundRect 
  139.                 ['] tempRect 4 4 CALL FrameRoundRect
  140.                 LOOP
  141.             ht +LOOP
  142.         ENDOF
  143.  
  144.         mChooseMsg OF
  145.             whichItem w@ -> wi#
  146.             ['] ItemRect wi# 1- 4 /mod ht * top + swap wd * left + swap
  147.                     over wd + over ht +  call setrect
  148.             hitPt menuRect call PtInrect
  149.             IF
  150.               4 0 DO
  151.                 4 0 DO 
  152.                 i j 4 * + 1+ -> item#
  153.                 ['] temprect left i wd * + top j ht * + over wd + over ht +
  154.                     call setrect   
  155.                 hitPt ['] tempRect call PtInRect 
  156.                     IF item# wi# <>
  157.                         IF    ['] ItemRect 4 4 call InvertRoundRect
  158.                             ['] tempRect 4 4 call InvertRoundRect
  159.                              item# whichItem w!
  160.                         THEN
  161.                     THEN
  162.                 LOOP
  163.               LOOP
  164.             ELSE
  165.               wi# IF ['] ItemRect 4 4 call InvertRoundRect THEN
  166.               0 whichItem w!
  167.             THEN
  168.         ENDOF
  169.  
  170.         mSizeMsg OF  
  171.             100 theMenu @ menuWidth  + w!
  172.             100 theMenu @ menuHeight + w!
  173.         ENDOF
  174.     ENDCASE
  175. ;
  176.  
  177. ( *** glue routine *** )
  178.  
  179. CODE custom.menu
  180.     LINK    A6,#-512             ( 512 bytes of local Forth stack )
  181.     MOVEM.L A0-A5/D0-D7,-(A7)    ( save registers )
  182.     MOVE.L A6,A3                ( setup local loop return stack )
  183.     SUBA.L #256,A3                ( in the low 256 local stack bytes )
  184.     MOVE.L 8(A6),D0             ( VAR whichItem: INTEGER )
  185.     MOVE.L 12(A6),D1             ( hitPt: Point )
  186.     MOVE.L 16(A6),A0            ( VAR menuRect: Rect )
  187.     MOVE.L 20(A6),A1             ( theMenu: MenuHandle )
  188.     MOVEQ.L #0,D2
  189.     MOVE.W 24(A6),D2             ( message: INTEGER )
  190.  
  191.     MOVE.L D2,-(A6)
  192.     MOVE.L A1,-(A6)
  193.     MOVE.L A0,-(A6)
  194.     MOVE.L D1,-(A6)
  195.     MOVE.L D0,-(A6)
  196.  
  197.     JSR mdef                    ( call Forth routine )
  198.  
  199.     MOVEM.L (A7)+,A0-A5/D0-D7    ( restore registers )
  200.     UNLK    A6
  201.     MOVE.L    (A7)+,A0            ( return address )
  202.     ADD.W    #18,A7                ( pop off 18 bytes of parameters )
  203.     JMP        (A0)
  204. END-CODE
  205.  
  206. header end
  207.  
  208. ' custom.menu ' start 2+ - ' start 2+ w!
  209.  
  210. ( *** installation *** )
  211. variable Hregular
  212.  
  213. : install.custom { menu# | mh procH -- }
  214.     menu# call getMHandle -> mh
  215.     mh 0= abort" Non-existing menu ID given."
  216.     ['] start ['] end over - call PtrToHand 
  217.         abort" Can't get enough memory to install."
  218.         -> procH 
  219.     mh call HLock
  220.     mh @ menuProc + @ Hregular !
  221.     procH mh @ menuProc + !
  222.     mh call HUnLock
  223.     . . cr
  224. ;
  225.  
  226. : remove.custom { menu# | mh procH -- }
  227.     menu# call getMHandle -> mh
  228.     mh 0= abort" Non-existing menu ID given."
  229.     mh call HLock
  230.     mh @ menuProc + @ call DisposHandle
  231.     Hregular @ mh @ menuProc + !
  232.     mh call HUnLock
  233.     . . . cr
  234. ;
  235.  
  236. ( *** making a resource *** )
  237. : $create-res call CreateResFile call ResError L_ext ;
  238.  
  239. : $open-res { addr | refNum -- result }
  240.     addr call openresfile -> refNum
  241.     call ResError L_ext
  242.     dup not IF drop refNum THEN 
  243. ;
  244.  
  245. : $close-res call CloseResFile call ResError L_ext ;
  246.  
  247. : make-mdef { | refNum -- }
  248.     " mdef.res" dup $create-res
  249.     abort" You have to delete the old 'mdef.res' file first."
  250.     $open-res dup -> refNum call UseResFile 
  251.     ['] start ['] end over - call PtrToHand drop ( result code )
  252.         "mdef 1 " Mach2 MDEF" call AddResource
  253.     refNum $close-res drop ( result code )
  254. ;
  255.  
  256.      
  257.  
  258.  
  259.